home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / tcltk / tk8.4 / button.tcl < prev    next >
Text File  |  2009-04-29  |  17KB  |  638 lines
  1. # button.tcl --
  2. #
  3. # This file defines the default bindings for Tk label, button,
  4. # checkbutton, and radiobutton widgets and provides procedures
  5. # that help in implementing those bindings.
  6. #
  7. # RCS: @(#) $Id: button.tcl,v 1.17.2.1 2006/01/25 18:21:41 dgp Exp $
  8. #
  9. # Copyright (c) 1992-1994 The Regents of the University of California.
  10. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  11. # Copyright (c) 2002 ActiveState Corporation.
  12. #
  13. # See the file "license.terms" for information on usage and redistribution
  14. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15. #
  16.  
  17. #-------------------------------------------------------------------------
  18. # The code below creates the default class bindings for buttons.
  19. #-------------------------------------------------------------------------
  20.  
  21. if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} {
  22.     bind Radiobutton <Enter> {
  23.     tk::ButtonEnter %W
  24.     }
  25.     bind Radiobutton <1> {
  26.     tk::ButtonDown %W
  27.     }
  28.     bind Radiobutton <ButtonRelease-1> {
  29.     tk::ButtonUp %W
  30.     }
  31.     bind Checkbutton <Enter> {
  32.     tk::ButtonEnter %W
  33.     }
  34.     bind Checkbutton <1> {
  35.     tk::ButtonDown %W
  36.     }
  37.     bind Checkbutton <ButtonRelease-1> {
  38.     tk::ButtonUp %W
  39.     }
  40. }
  41. if {"windows" eq $tcl_platform(platform)} {
  42.     bind Checkbutton <equal> {
  43.     tk::CheckRadioInvoke %W select
  44.     }
  45.     bind Checkbutton <plus> {
  46.     tk::CheckRadioInvoke %W select
  47.     }
  48.     bind Checkbutton <minus> {
  49.     tk::CheckRadioInvoke %W deselect
  50.     }
  51.     bind Checkbutton <1> {
  52.     tk::CheckRadioDown %W
  53.     }
  54.     bind Checkbutton <ButtonRelease-1> {
  55.     tk::ButtonUp %W
  56.     }
  57.     bind Checkbutton <Enter> {
  58.     tk::CheckRadioEnter %W
  59.     }
  60.  
  61.     bind Radiobutton <1> {
  62.     tk::CheckRadioDown %W
  63.     }
  64.     bind Radiobutton <ButtonRelease-1> {
  65.     tk::ButtonUp %W
  66.     }
  67.     bind Radiobutton <Enter> {
  68.     tk::CheckRadioEnter %W
  69.     }
  70. }
  71. if {"x11" eq [tk windowingsystem]} {
  72.     bind Checkbutton <Return> {
  73.     if {!$tk_strictMotif} {
  74.         tk::CheckRadioInvoke %W
  75.     }
  76.     }
  77.     bind Radiobutton <Return> {
  78.     if {!$tk_strictMotif} {
  79.         tk::CheckRadioInvoke %W
  80.     }
  81.     }
  82.     bind Checkbutton <1> {
  83.     tk::CheckRadioInvoke %W
  84.     }
  85.     bind Radiobutton <1> {
  86.     tk::CheckRadioInvoke %W
  87.     }
  88.     bind Checkbutton <Enter> {
  89.     tk::ButtonEnter %W
  90.     }
  91.     bind Radiobutton <Enter> {
  92.     tk::ButtonEnter %W
  93.     }
  94. }
  95.  
  96. bind Button <space> {
  97.     tk::ButtonInvoke %W
  98. }
  99. bind Checkbutton <space> {
  100.     tk::CheckRadioInvoke %W
  101. }
  102. bind Radiobutton <space> {
  103.     tk::CheckRadioInvoke %W
  104. }
  105.  
  106. bind Button <FocusIn> {}
  107. bind Button <Enter> {
  108.     tk::ButtonEnter %W
  109. }
  110. bind Button <Leave> {
  111.     tk::ButtonLeave %W
  112. }
  113. bind Button <1> {
  114.     tk::ButtonDown %W
  115. }
  116. bind Button <ButtonRelease-1> {
  117.     tk::ButtonUp %W
  118. }
  119.  
  120. bind Checkbutton <FocusIn> {}
  121. bind Checkbutton <Leave> {
  122.     tk::ButtonLeave %W
  123. }
  124.  
  125. bind Radiobutton <FocusIn> {}
  126. bind Radiobutton <Leave> {
  127.     tk::ButtonLeave %W
  128. }
  129.  
  130. if {"windows" eq $tcl_platform(platform)} {
  131.  
  132. #########################
  133. # Windows implementation 
  134. #########################
  135.  
  136. # ::tk::ButtonEnter --
  137. # The procedure below is invoked when the mouse pointer enters a
  138. # button widget.  It records the button we're in and changes the
  139. # state of the button to active unless the button is disabled.
  140. #
  141. # Arguments:
  142. # w -        The name of the widget.
  143.  
  144. proc ::tk::ButtonEnter w {
  145.     variable ::tk::Priv
  146.     if {[$w cget -state] ne "disabled"} {
  147.  
  148.     # If the mouse button is down, set the relief to sunken on entry.
  149.     # Overwise, if there's an -overrelief value, set the relief to that.
  150.  
  151.     set Priv($w,relief) [$w cget -relief]
  152.     if {$Priv(buttonWindow) eq $w} {
  153.         $w configure -relief sunken -state active
  154.         set Priv($w,prelief) sunken
  155.     } elseif {[set over [$w cget -overrelief]] ne ""} {
  156.         $w configure -relief $over
  157.         set Priv($w,prelief) $over
  158.     }
  159.     }
  160.     set Priv(window) $w
  161. }
  162.  
  163. # ::tk::ButtonLeave --
  164. # The procedure below is invoked when the mouse pointer leaves a
  165. # button widget.  It changes the state of the button back to inactive.
  166. # Restore any modified relief too.
  167. #
  168. # Arguments:
  169. # w -        The name of the widget.
  170.  
  171. proc ::tk::ButtonLeave w {
  172.     variable ::tk::Priv
  173.     if {[$w cget -state] ne "disabled"} {
  174.     $w configure -state normal
  175.     }
  176.  
  177.     # Restore the original button relief if it was changed by Tk.
  178.     # That is signaled by the existence of Priv($w,prelief).
  179.  
  180.     if {[info exists Priv($w,relief)]} {
  181.     if {[info exists Priv($w,prelief)] && \
  182.         $Priv($w,prelief) eq [$w cget -relief]} {
  183.         $w configure -relief $Priv($w,relief)
  184.     }
  185.     unset -nocomplain Priv($w,relief) Priv($w,prelief)
  186.     }
  187.  
  188.     set Priv(window) ""
  189. }
  190.  
  191. # ::tk::ButtonDown --
  192. # The procedure below is invoked when the mouse button is pressed in
  193. # a button widget.  It records the fact that the mouse is in the button,
  194. # saves the button's relief so it can be restored later, and changes
  195. # the relief to sunken.
  196. #
  197. # Arguments:
  198. # w -        The name of the widget.
  199.  
  200. proc ::tk::ButtonDown w {
  201.     variable ::tk::Priv
  202.  
  203.     # Only save the button's relief if it does not yet exist.  If there
  204.     # is an overrelief setting, Priv($w,relief) will already have been set,
  205.     # and the current value of the -relief option will be incorrect.
  206.  
  207.     if {![info exists Priv($w,relief)]} {
  208.     set Priv($w,relief) [$w cget -relief]
  209.     }
  210.  
  211.     if {[$w cget -state] ne "disabled"} {
  212.     set Priv(buttonWindow) $w
  213.     $w configure -relief sunken -state active
  214.     set Priv($w,prelief) sunken
  215.  
  216.     # If this button has a repeatdelay set up, get it going with an after
  217.     after cancel $Priv(afterId)
  218.     set delay [$w cget -repeatdelay]
  219.     set Priv(repeated) 0
  220.     if {$delay > 0} {
  221.         set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
  222.     }
  223.     }
  224. }
  225.  
  226. # ::tk::ButtonUp --
  227. # The procedure below is invoked when the mouse button is released
  228. # in a button widget.  It restores the button's relief and invokes
  229. # the command as long as the mouse hasn't left the button.
  230. #
  231. # Arguments:
  232. # w -        The name of the widget.
  233.  
  234. proc ::tk::ButtonUp w {
  235.     variable ::tk::Priv
  236.     if {$Priv(buttonWindow) eq $w} {
  237.     set Priv(buttonWindow) ""
  238.  
  239.     # Restore the button's relief if it was cached.
  240.  
  241.     if {[info exists Priv($w,relief)]} {
  242.         if {[info exists Priv($w,prelief)] && \
  243.             $Priv($w,prelief) eq [$w cget -relief]} {
  244.         $w configure -relief $Priv($w,relief)
  245.         }
  246.         unset -nocomplain Priv($w,relief) Priv($w,prelief)
  247.     }
  248.  
  249.     # Clean up the after event from the auto-repeater
  250.     after cancel $Priv(afterId)
  251.  
  252.     if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
  253.         $w configure -state normal
  254.  
  255.         # Only invoke the command if it wasn't already invoked by the
  256.         # auto-repeater functionality
  257.         if { $Priv(repeated) == 0 } {
  258.         uplevel #0 [list $w invoke]
  259.         }
  260.     }
  261.     }
  262. }
  263.  
  264. # ::tk::CheckRadioEnter --
  265. # The procedure below is invoked when the mouse pointer enters a
  266. # checkbutton or radiobutton widget.  It records the button we're in
  267. # and changes the state of the button to active unless the button is
  268. # disabled.
  269. #
  270. # Arguments:
  271. # w -        The name of the widget.
  272.  
  273. proc ::tk::CheckRadioEnter w {
  274.     variable ::tk::Priv
  275.     if {[$w cget -state] ne "disabled"} {
  276.     if {$Priv(buttonWindow) eq $w} {
  277.         $w configure -state active
  278.     }
  279.     if {[set over [$w cget -overrelief]] ne ""} {
  280.         set Priv($w,relief)  [$w cget -relief]
  281.         set Priv($w,prelief) $over
  282.         $w configure -relief $over
  283.     }
  284.     }
  285.     set Priv(window) $w
  286. }
  287.  
  288. # ::tk::CheckRadioDown --
  289. # The procedure below is invoked when the mouse button is pressed in
  290. # a button widget.  It records the fact that the mouse is in the button,
  291. # saves the button's relief so it can be restored later, and changes
  292. # the relief to sunken.
  293. #
  294. # Arguments:
  295. # w -        The name of the widget.
  296.  
  297. proc ::tk::CheckRadioDown w {
  298.     variable ::tk::Priv
  299.     if {![info exists Priv($w,relief)]} {
  300.     set Priv($w,relief) [$w cget -relief]
  301.     }
  302.     if {[$w cget -state] ne "disabled"} {
  303.     set Priv(buttonWindow) $w
  304.     set Priv(repeated) 0
  305.     $w configure -state active
  306.     }
  307. }
  308.  
  309. }
  310.  
  311. if {"x11" eq [tk windowingsystem]} {
  312.  
  313. #####################
  314. # Unix implementation
  315. #####################
  316.  
  317. # ::tk::ButtonEnter --
  318. # The procedure below is invoked when the mouse pointer enters a
  319. # button widget.  It records the button we're in and changes the
  320. # state of the button to active unless the button is disabled.
  321. #
  322. # Arguments:
  323. # w -        The name of the widget.
  324.  
  325. proc ::tk::ButtonEnter {w} {
  326.     variable ::tk::Priv
  327.     if {[$w cget -state] ne "disabled"} {
  328.     # On unix the state is active just with mouse-over
  329.     $w configure -state active
  330.  
  331.     # If the mouse button is down, set the relief to sunken on entry.
  332.     # Overwise, if there's an -overrelief value, set the relief to that.
  333.  
  334.     set Priv($w,relief) [$w cget -relief]
  335.     if {$Priv(buttonWindow) eq $w} {
  336.         $w configure -relief sunken
  337.         set Priv($w,prelief) sunken
  338.     } elseif {[set over [$w cget -overrelief]] ne ""} {
  339.         $w configure -relief $over
  340.         set Priv($w,prelief) $over
  341.     }
  342.     }
  343.     set Priv(window) $w
  344. }
  345.  
  346. # ::tk::ButtonLeave --
  347. # The procedure below is invoked when the mouse pointer leaves a
  348. # button widget.  It changes the state of the button back to inactive.
  349. # Restore any modified relief too.
  350. #
  351. # Arguments:
  352. # w -        The name of the widget.
  353.  
  354. proc ::tk::ButtonLeave w {
  355.     variable ::tk::Priv
  356.     if {[$w cget -state] ne "disabled"} {
  357.     $w configure -state normal
  358.     }
  359.  
  360.     # Restore the original button relief if it was changed by Tk.
  361.     # That is signaled by the existence of Priv($w,prelief).
  362.  
  363.     if {[info exists Priv($w,relief)]} {
  364.     if {[info exists Priv($w,prelief)] && \
  365.         $Priv($w,prelief) eq [$w cget -relief]} {
  366.         $w configure -relief $Priv($w,relief)
  367.     }
  368.     unset -nocomplain Priv($w,relief) Priv($w,prelief)
  369.     }
  370.  
  371.     set Priv(window) ""
  372. }
  373.  
  374. # ::tk::ButtonDown --
  375. # The procedure below is invoked when the mouse button is pressed in
  376. # a button widget.  It records the fact that the mouse is in the button,
  377. # saves the button's relief so it can be restored later, and changes
  378. # the relief to sunken.
  379. #
  380. # Arguments:
  381. # w -        The name of the widget.
  382.  
  383. proc ::tk::ButtonDown w {
  384.     variable ::tk::Priv
  385.  
  386.     # Only save the button's relief if it does not yet exist.  If there
  387.     # is an overrelief setting, Priv($w,relief) will already have been set,
  388.     # and the current value of the -relief option will be incorrect.
  389.  
  390.     if {![info exists Priv($w,relief)]} {
  391.     set Priv($w,relief) [$w cget -relief]
  392.     }
  393.  
  394.     if {[$w cget -state] ne "disabled"} {
  395.     set Priv(buttonWindow) $w
  396.     $w configure -relief sunken
  397.     set Priv($w,prelief) sunken
  398.  
  399.     # If this button has a repeatdelay set up, get it going with an after
  400.     after cancel $Priv(afterId)
  401.     set delay [$w cget -repeatdelay]
  402.     set Priv(repeated) 0
  403.     if {$delay > 0} {
  404.         set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
  405.     }
  406.     }
  407. }
  408.  
  409. # ::tk::ButtonUp --
  410. # The procedure below is invoked when the mouse button is released
  411. # in a button widget.  It restores the button's relief and invokes
  412. # the command as long as the mouse hasn't left the button.
  413. #
  414. # Arguments:
  415. # w -        The name of the widget.
  416.  
  417. proc ::tk::ButtonUp w {
  418.     variable ::tk::Priv
  419.     if {$w eq $Priv(buttonWindow)} {
  420.     set Priv(buttonWindow) ""
  421.  
  422.     # Restore the button's relief if it was cached.
  423.  
  424.     if {[info exists Priv($w,relief)]} {
  425.         if {[info exists Priv($w,prelief)] && \
  426.             $Priv($w,prelief) eq [$w cget -relief]} {
  427.         $w configure -relief $Priv($w,relief)
  428.         }
  429.         unset -nocomplain Priv($w,relief) Priv($w,prelief)
  430.     }
  431.  
  432.     # Clean up the after event from the auto-repeater
  433.     after cancel $Priv(afterId)
  434.  
  435.     if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
  436.         # Only invoke the command if it wasn't already invoked by the
  437.         # auto-repeater functionality
  438.         if { $Priv(repeated) == 0 } {
  439.         uplevel #0 [list $w invoke]
  440.         }
  441.     }
  442.     }
  443. }
  444.  
  445. }
  446.  
  447. if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} {
  448.  
  449. ####################
  450. # Mac implementation
  451. ####################
  452.  
  453. # ::tk::ButtonEnter --
  454. # The procedure below is invoked when the mouse pointer enters a
  455. # button widget.  It records the button we're in and changes the
  456. # state of the button to active unless the button is disabled.
  457. #
  458. # Arguments:
  459. # w -        The name of the widget.
  460.  
  461. proc ::tk::ButtonEnter {w} {
  462.     variable ::tk::Priv
  463.     if {[$w cget -state] ne "disabled"} {
  464.  
  465.     # If there's an -overrelief value, set the relief to that.
  466.  
  467.     if {$Priv(buttonWindow) eq $w} {
  468.         $w configure -state active
  469.     } elseif {[set over [$w cget -overrelief]] ne ""} {
  470.         set Priv($w,relief)  [$w cget -relief]
  471.         set Priv($w,prelief) $over
  472.         $w configure -relief $over
  473.     }
  474.     }
  475.     set Priv(window) $w
  476. }
  477.  
  478. # ::tk::ButtonLeave --
  479. # The procedure below is invoked when the mouse pointer leaves a
  480. # button widget.  It changes the state of the button back to
  481. # inactive.  If we're leaving the button window with a mouse button
  482. # pressed (Priv(buttonWindow) == $w), restore the relief of the
  483. # button too.
  484. #
  485. # Arguments:
  486. # w -        The name of the widget.
  487.  
  488. proc ::tk::ButtonLeave w {
  489.     variable ::tk::Priv
  490.     if {$w eq $Priv(buttonWindow)} {
  491.     $w configure -state normal
  492.     }
  493.  
  494.     # Restore the original button relief if it was changed by Tk.
  495.     # That is signaled by the existence of Priv($w,prelief).
  496.  
  497.     if {[info exists Priv($w,relief)]} {
  498.     if {[info exists Priv($w,prelief)] && \
  499.         $Priv($w,prelief) eq [$w cget -relief]} {
  500.         $w configure -relief $Priv($w,relief)
  501.     }
  502.     unset -nocomplain Priv($w,relief) Priv($w,prelief)
  503.     }
  504.  
  505.     set Priv(window) ""
  506. }
  507.  
  508. # ::tk::ButtonDown --
  509. # The procedure below is invoked when the mouse button is pressed in
  510. # a button widget.  It records the fact that the mouse is in the button,
  511. # saves the button's relief so it can be restored later, and changes
  512. # the relief to sunken.
  513. #
  514. # Arguments:
  515. # w -        The name of the widget.
  516.  
  517. proc ::tk::ButtonDown w {
  518.     variable ::tk::Priv
  519.  
  520.     if {[$w cget -state] ne "disabled"} {
  521.     set Priv(buttonWindow) $w
  522.     $w configure -state active
  523.  
  524.     # If this button has a repeatdelay set up, get it going with an after
  525.     after cancel $Priv(afterId)
  526.     set Priv(repeated) 0
  527.     if { ![catch {$w cget -repeatdelay} delay] } {
  528.         if {$delay > 0} {
  529.         set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
  530.         }
  531.     }
  532.     }
  533. }
  534.  
  535. # ::tk::ButtonUp --
  536. # The procedure below is invoked when the mouse button is released
  537. # in a button widget.  It restores the button's relief and invokes
  538. # the command as long as the mouse hasn't left the button.
  539. #
  540. # Arguments:
  541. # w -        The name of the widget.
  542.  
  543. proc ::tk::ButtonUp w {
  544.     variable ::tk::Priv
  545.     if {$Priv(buttonWindow) eq $w} {
  546.     set Priv(buttonWindow) ""
  547.     $w configure -state normal
  548.  
  549.     # Restore the button's relief if it was cached.
  550.  
  551.     if {[info exists Priv($w,relief)]} {
  552.         if {[info exists Priv($w,prelief)] && \
  553.             $Priv($w,prelief) eq [$w cget -relief]} {
  554.         $w configure -relief $Priv($w,relief)
  555.         }
  556.         unset -nocomplain Priv($w,relief) Priv($w,prelief)
  557.     }
  558.  
  559.     # Clean up the after event from the auto-repeater
  560.     after cancel $Priv(afterId)
  561.  
  562.     if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
  563.         # Only invoke the command if it wasn't already invoked by the
  564.         # auto-repeater functionality
  565.         if { $Priv(repeated) == 0 } {
  566.         uplevel #0 [list $w invoke]
  567.         }
  568.     }
  569.     }
  570. }
  571.  
  572. }
  573.  
  574. ##################
  575. # Shared routines
  576. ##################
  577.  
  578. # ::tk::ButtonInvoke --
  579. # The procedure below is called when a button is invoked through
  580. # the keyboard.  It simulate a press of the button via the mouse.
  581. #
  582. # Arguments:
  583. # w -        The name of the widget.
  584.  
  585. proc ::tk::ButtonInvoke w {
  586.     if {[$w cget -state] ne "disabled"} {
  587.     set oldRelief [$w cget -relief]
  588.     set oldState [$w cget -state]
  589.     $w configure -state active -relief sunken
  590.     update idletasks
  591.     after 100
  592.     $w configure -state $oldState -relief $oldRelief
  593.     uplevel #0 [list $w invoke]
  594.     }
  595. }
  596.  
  597. # ::tk::ButtonAutoInvoke --
  598. #
  599. #    Invoke an auto-repeating button, and set it up to continue to repeat.
  600. #
  601. # Arguments:
  602. #    w    button to invoke.
  603. #
  604. # Results:
  605. #    None.
  606. #
  607. # Side effects:
  608. #    May create an after event to call ::tk::ButtonAutoInvoke.
  609.  
  610. proc ::tk::ButtonAutoInvoke {w} {
  611.     variable ::tk::Priv
  612.     after cancel $Priv(afterId)
  613.     set delay [$w cget -repeatinterval]
  614.     if {$Priv(window) eq $w} {
  615.     incr Priv(repeated)
  616.     uplevel #0 [list $w invoke]
  617.     }
  618.     if {$delay > 0} {
  619.     set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
  620.     }
  621. }
  622.  
  623. # ::tk::CheckRadioInvoke --
  624. # The procedure below is invoked when the mouse button is pressed in
  625. # a checkbutton or radiobutton widget, or when the widget is invoked
  626. # through the keyboard.  It invokes the widget if it
  627. # isn't disabled.
  628. #
  629. # Arguments:
  630. # w -        The name of the widget.
  631. # cmd -        The subcommand to invoke (one of invoke, select, or deselect).
  632.  
  633. proc ::tk::CheckRadioInvoke {w {cmd invoke}} {
  634.     if {[$w cget -state] ne "disabled"} {
  635.     uplevel #0 [list $w $cmd]
  636.     }
  637. }
  638.